home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
kcl
/
kcl.lha
/
cmpnew
/
cmputil.lsp
< prev
next >
Wrap
Lisp/Scheme
|
1987-06-03
|
6KB
|
208 lines
;;; CMPUTIL Miscellaneous Functions.
;;;
;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984. All rights reserved.
;; Copying of this file is authorized to users who have executed the true and
;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
(in-package 'compiler)
(export '(*suppress-compiler-warnings*
*suppress-compiler-notes*
*compiler-break-enable*))
(defmacro safe-compile (&rest forms) `(when *safe-compile* ,@forms))
(defvar *current-form* '|compiler preprocess|)
(defvar *first-error* t)
(defvar *error-count* 0)
(defconstant *cmperr-tag* (cons nil nil))
(defun cmperr (string &rest args &aux (*print-case* :upcase))
(print-current-form)
(format t "~&;;; ")
(apply #'format t string args)
(incf *error-count*)
(throw *cmperr-tag* '*cmperr-tag*))
(defmacro cmpck (condition string &rest args)
`(if ,condition (cmperr ,string ,@args)))
(defun too-many-args (name upper-bound n &aux (*print-case* :upcase))
(print-current-form)
(format t
";;; ~S requires at most ~R argument~:p, ~
but ~R ~:*~[were~;was~:;were~] supplied.~%"
name
upper-bound
n)
(incf *error-count*)
(throw *cmperr-tag* '*cmperr-tag*))
(defun too-few-args (name lower-bound n &aux (*print-case* :upcase))
(print-current-form)
(format t
";;; ~S requires at least ~R argument~:p, ~
but only ~R ~:*~[were~;was~:;were~] supplied.~%"
name
lower-bound
n)
(incf *error-count*)
(throw *cmperr-tag* '*cmperr-tag*))
(defvar *suppress-compiler-warnings* nil)
(defun cmpwarn (string &rest args &aux (*print-case* :upcase))
(unless *suppress-compiler-warnings*
(print-current-form)
(format t ";; Warning: ")
(apply #'format t string args)
(terpri))
nil)
(defvar *suppress-compiler-notes* nil)
(defun cmpnote (string &rest args &aux (*print-case* :upcase))
(unless *suppress-compiler-notes*
(terpri)
(format t ";; Note: ")
(apply #'format t string args))
nil)
(defun print-current-form ()
(when *first-error*
(setq *first-error* nil)
(fresh-line)
(cond
((and (consp *current-form*)
(eq (car *current-form*) 'si:|#,|))
(format t "; #,~s is being compiled.~%" (cdr *current-form*)))
(t
(let ((*print-length* 2)
(*print-level* 2))
(format t "; ~s is being compiled.~%" *current-form*)))))
nil)
(defun undefined-variable (sym &aux (*print-case* :upcase))
(print-current-form)
(format t
";; The variable ~s is undefined.~%~
;; The compiler will assume this variable is a global.~%"
sym)
nil)
(defun baboon (&aux (*print-case* :upcase))
(print-current-form)
(format t ";;; A bug was found in the compiler. Contact Taiichi.~%")
(incf *error-count*)
(break)
; (throw *cmperr-tag* '*cmperr-tag*)
)
;;; Internal Macros with type declarations
(defmacro dolist* ((v l &optional (val nil)) . body)
(let ((temp (gensym)))
`(do* ((,temp ,l (cdr ,temp)) (,v (car ,temp) (car ,temp)))
((endp ,temp) ,val)
(declare (object ,v))
,@body)))
(defmacro dolist** ((v l &optional (val nil)) . body)
(let ((temp (gensym)))
`(do* ((,temp ,l (cdr ,temp)) (,v (car ,temp) (car ,temp)))
((endp ,temp) ,val)
(declare (object ,temp ,v))
,@body)))
(defmacro dotimes* ((v n &optional (val nil)) . body)
(let ((temp (gensym)))
`(do* ((,temp ,n) (,v 0 (1+ ,v)))
((>= ,v ,temp) ,val)
(declare (fixnum ,v))
,@body)))
(defmacro dotimes** ((v n &optional (val nil)) . body)
(let ((temp (gensym)))
`(do* ((,temp ,n) (,v 0 (1+ ,v)))
((>= ,v ,temp) ,val)
(declare (fixnum ,temp ,v))
,@body)))
(defun cmp-eval (form)
(let ((x (multiple-value-list (cmp-toplevel-eval `(eval ',form)))))
(if (car x)
(let ((*print-case* :upcase))
(incf *error-count*)
(print-current-form)
(format t
";;; The form ~s was not evaluated successfully.~%~
;;; You are recommended to compile again.~%"
form)
nil)
(values-list (cdr x)))))
(defun cmp-macroexpand (form)
(let ((x (multiple-value-list (cmp-toplevel-eval `(macroexpand ',form)))))
(if (car x)
(let ((*print-case* :upcase))
(incf *error-count*)
(print-current-form)
(format t
";;; The macro form ~s was not expanded successfully.~%"
form)
`(error "Macro-expansion of ~s failed at compile time." ',form))
(cadr x))))
(defun cmp-macroexpand-1 (form)
(let ((x (multiple-value-list (cmp-toplevel-eval `(macroexpand-1 ',form)))))
(if (car x)
(let ((*print-case* :upcase))
(incf *error-count*)
(print-current-form)
(format t
";;; The macro form ~s was not expanded successfully.~%"
form)
`(error "Macro-expansion of ~s failed at compile time." ',form))
(cadr x))))
(defun cmp-expand-macro (fd fname args)
(let ((x (multiple-value-list
(cmp-toplevel-eval
`(funcall *macroexpand-hook* ',fd ',(cons fname args) nil)))))
(if (car x)
(let ((*print-case* :upcase))
(incf *error-count*)
(print-current-form)
(format t
";;; The macro form (~s ...) was not expanded successfully.~%"
fname)
`(error "Macro-expansion of ~s failed at compile time."
',(cons fname args)))
(cadr x))))
(defvar *compiler-break-enable* nil)
(defun cmp-toplevel-eval (form)
(let* ((si::*ihs-base* si::*ihs-top*)
(si::*ihs-top* (1- (si::ihs-top)))
(*break-enable* *compiler-break-enable*)
(si::*break-hidden-packages*
(cons (find-package 'compiler)
si::*break-hidden-packages*)))
(si:error-set form)))
(defun compiler-clear-compiler-properties (symbol)
(remprop symbol 'package-operation)
(remprop symbol 't1)
(remprop symbol 't2)
(remprop symbol 't3)
(remprop symbol 'top-level-macro)
(remprop symbol 'c1)
(remprop symbol 'c2)
(remprop symbol 'c1conditional)
(remprop symbol 'inline-always)
(remprop symbol 'inline-unsafe)
(remprop symbol 'inline-safe)
(remprop symbol 'lfun))